!     ******************************************************************
!     *                                                                *
!     *   MULTIGRID MODULE                                             *
!     *                                                                *
!     ******************************************************************

!     ******************************************************************
!     *                                                                *
!     *   COPYRIGHT (C) ANTONY JAMESON 1988                            *
!     *                                                                *
!     ******************************************************************

!     NAME=MOVCO
      SUBROUTINE MOVCO

!     ******************************************************************
!     *                                                                *
!     *   MOVE TO A COARSER MESH                                       *
!     *                                                                *
!     ******************************************************************
      USE CARBUNCLE
      IMPLICIT NONE

!      PARAMETER  (IDM=385,JDM=65)                  ! MOVED TO MODULE CARBUNCLE
!      PARAMETER  (IDN=IDM+1,JDN=JDM+1)
!      PARAMETER  (IDX=9096,IDX2=2*IDX,IDX4=4*IDX)
!      COMMON/DAT/ GAMMA,RM,RHO0,P0,EI0,H0,C0,U0,V0,CA,SA,ALPHA
!      COMMON/LIM/ NX,NY,IL,JL,IE,JE,ITL,ITU
!      COMMON/FLO/ W(IDN,JDN,4),P(IDN,JDN)
!      COMMON/GRD/ X(IDM,JDM,2),VOL(IDN,JDN)
!      COMMON/EXT/ WW(IDX4),WW1(IDX4),WWR(IDX4),
!     .            XX(IDX2),VOLC(IDX)
!      COMMON/CRD/ A0(IDM),S0(IDM),B0(JDM),XSING,YSING,TRAIL,SLOPT,
!     .            BOUNDX,BOUNDY,BX,XTE,XLIM,AX,AY,SY
!      COMMON/CYC/ MCYC,NCYC,NTIM,NOUT,NPRNT,IPRNT,LPRNT,NMESH,K1,KX,KW
!      COMMON/MGR/ KODE,MODE,FCOLL,FADD,FBC

!     ******************************************************************

      INTEGER :: IIL,JJL,IIE,JJE,NC,L,ILE,I,J
      DOUBLE PRECISION :: QQ

      IIL       = NX/2  +1
      JJL       = NY/2  +1
      IIE       = NX/2  +2
      JJE       = NY/2  +2

!     TRANSFER THE SOLUTION AND RESIDUALS TO A COARSER MESH

      IF (MODE.GE.0) CALL COLLC (IIE,JJE,WW(KW),WWR(KW))

!     EXPAND THE MESH

      IF (MODE.LT.0.OR.NCYC.EQ.1) CALL XPAND (IIL,JJL,XX(KX))

!     EXCHANGE VARIABLES BETWEEN THE COARSE AND FINE MESHES

      CALL SHIFT (IIL,JJL,IIE,JJE,WW(KW),WW1(KW),WWR(KW),&
                  XX(KX),VOLC(K1))
      NC        = IIE*JJE
      K1        = K1  +NC
      KX        = KX  +2*NC
      KW        = KW  +4*NC
      NX        = NX/2
      NY        = NY/2
      IL        = NX  +1
      JL        = NY  +1
      IE        = NX  +2
      JE        = NY  +2
      L         = .5000005*XTE*(IL  -1)
      ILE       = IL/2  +1
      ITL       = ILE  -L
      ITU       = ILE  +L
      IF (MODE.LT.0) RETURN

!     CALCULATE THE CELL AREAS

      IF (NCYC.EQ.1) CALL METRIC

!     CALCULATE THE PRESSURE

      DO 10 J=2,JE
      DO 10 I=1,IE
      QQ        = .5*(W(I,J,2)**2  +W(I,J,3)**2)/W(I,J,1)
      P(I,J)    = (GAMMA  -1.)*DIM(W(I,J,4),QQ)
   10 CONTINUE

!     UPDATE THE SURFACE PRESSURE

      CALL BCWALL

!     OPTION TO UPDATE THE FAR FIELD

      IF (FBC.GT.0.) CALL BCFAR
      RETURN
      END SUBROUTINE MOVCO

